home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / boost4.zip / PULLDOWN.PAS < prev    next >
Pascal/Delphi Source File  |  1988-10-23  |  7KB  |  263 lines
  1. Program PullDown;
  2.  
  3. { Demonstrates pull-down menus using Boosters v4.0,
  4.   a library of routines for Turbo Pascal 4.0
  5.   George F. Smith, Lilburn, GA  10/9/88
  6.  
  7.   PullDown calls the following Boosters routines:
  8.  
  9.     Name           Description                         Implementation
  10.     ----           -----------                         --------------
  11.     PutStr         Writes string to video at x,y          MASM 4.0
  12.     SetAtt         Sets video atts for block              MASM 4.0
  13.     Heap2Scr       Writes block from heap to screen       MASM 4.0
  14.     Disk2Mem       Reads video screen from file to heap   MASM 4.0
  15.     GetAtt         Returns the video attribute at x,y     MASM 4.0
  16.     SaveScreen     Writes current screen to page of heap  MASM 4.0
  17.     Scr2Heap       Writes video block to block of heap    MASM 4.0
  18.     HeapAtt        Sets video attributes of heap block    MASM 4.0
  19. }
  20.  
  21. Uses crt, BOSHARE;
  22.  
  23. Const
  24.    Npage = 2;
  25.    ESC   = #27;
  26.    ALTQ  = #16;
  27.    ALTT  = #20;
  28.    ALTF  = #33;
  29.    ALTE  = #18;
  30.    ALTV  = #47;
  31.    ALTS  = #31;
  32.    RA    = #77;
  33.    LA    = #75;
  34.    TX    =   6;
  35.    FX    =  16;
  36.    EX    =  26;
  37.    VX    =  36;
  38.    SX    =  46;
  39.    Attributes : array[0..5] of byte = (7,14,30,48,66,112);
  40.  
  41. Var
  42.    Page : array[1..Npage] of HeapBuf;
  43.    i, Ecode, Stall : integer;
  44.    CurrentAtt, att : byte;
  45.    c : char;
  46.    MenuSel : 0..4;
  47.  
  48. {-------------}
  49. function Fstr ( num : longint; width : integer) : String;
  50. var
  51.    s : string[80];
  52. begin
  53.    str ( num:width, s );
  54.    fstr := s;
  55. end;   { fstr }
  56.  
  57. {---------------------}
  58. Procedure ShowMessages;
  59. begin
  60.    PutStr (h,
  61.            'Sample pull-down menuing routine using BOOSTERS 4.0 library.',
  62.            1, 6, 14 );
  63.    Writeln;
  64.    Writeln;
  65.    Writeln('Press ALT-T for TSRs, ALT-F for File, etc. to see first menu,');
  66.    Writeln('then use left and right arrow keys to move from menu to menu.');
  67.    Writeln;
  68.    Writeln('Press ESCAPE to stop menuing, ALT-Q to quit.');
  69.    Writeln;
  70.    Writeln('When no menus are displayed:');
  71.    Writeln('   1)  +/- keys increase/decrease pull-down delay');
  72.    Writeln('       Current menu scroll delay value is ',stall:3);
  73.    Writeln('   2)  ''A'' changes the video attributes of the menus');
  74.    Writeln('       Current video attribute value is ',Attributes[CurrentAtt]:3);
  75.    Writeln;
  76.    Writeln('P.S.');
  77.    Writeln('   Pull-downs are for visual effects only, not for speed.');
  78. end;
  79.  
  80. {-----------------}
  81. Procedure Wait4Key;
  82. begin
  83.    repeat until keypressed;
  84.    c := readkey;
  85.    if c = #0 then
  86.       c := readkey;
  87. end;
  88.  
  89. {------------------}
  90. Procedure SelectMenu;
  91. begin
  92.    case c of
  93.       ALTT : MenuSel := 0;
  94.       ALTF : MenuSel := 1;
  95.       ALTE : MenuSel := 2;
  96.       ALTV : MenuSel := 3;
  97.       ALTS : MenuSel := 4;
  98.    end;
  99. end;
  100.  
  101. {---------------------}
  102. Procedure ShowNextMenu;
  103. begin
  104.    case c of
  105.       RA : if MenuSel >= 4 then
  106.               MenuSel := 0
  107.            else
  108.               MenuSel := MenuSel + 1;
  109.       LA : if MenuSel <= 0 then
  110.               MenuSel := 4
  111.            else
  112.               MenuSel := MenuSel - 1;
  113.    end;
  114.  
  115.    case MenuSel of
  116.       0 : begin
  117.              setatt ( TX,1,9,1,14 );
  118.              for i := 2 to 10 do begin
  119.                 delay(stall);
  120.                 heap2scr( Page[1],1,i,25,i,TX,i);
  121.              end;
  122.           end;
  123.       1 : begin
  124.              setatt ( FX,1,19,1,14);
  125.              for i := 2 to 17 do begin
  126.                 delay(stall);
  127.                 heap2scr( Page[1],26,i,50,i ,FX,i);
  128.              end;
  129.           end;
  130.       2 : begin
  131.              setatt ( EX,1,29,1,14);
  132.              for i := 2 to 9 do begin
  133.                 delay(stall);
  134.                 heap2scr( Page[1],51,i,75,i,EX,i);
  135.              end;
  136.           end;
  137.       3 : begin
  138.              setatt ( VX,1,39,1,14);
  139.              for i := 2 to 7 do begin
  140.                 delay(stall);
  141.                 heap2scr( Page[1],1,i+11,25,i+11,VX,i);
  142.              end;
  143.           end;
  144.       4 : begin
  145.              setatt ( SX,1,52,1,14);
  146.              for i := 2 to 7 do begin
  147.                 delay(stall);
  148.                 heap2scr( Page[1],26,i+16,50,i+16,SX,i);
  149.              end;
  150.           end;
  151.    end;
  152. end;
  153.  
  154. {---------------------}
  155. Procedure EraseCurMenu;
  156. begin
  157.    case MenuSel of
  158.       0 : begin
  159.              SetAtt (6,1,9,1,att);
  160.              heap2scr( Page[2],6,2,30,10,6,2);
  161.           end;
  162.       1 : begin
  163.              SetAtt (16,1,19,1,att);
  164.              heap2scr( Page[2],16,2,40,17,16,2);
  165.           end;
  166.       2 : begin
  167.              SetAtt (26,1,29,1,att);
  168.              heap2scr( Page[2],26,2,50,9,26,2);
  169.           end;
  170.       3 : begin
  171.              SetAtt (36,1,39,1,att);
  172.              heap2scr( Page[2],36, 2,60, 7,36,2);
  173.           end;
  174.       4 : begin
  175.              SetAtt (46,1,52,1,att);
  176.              heap2scr( Page[2],46, 2,70, 7,46,2);
  177.           end;
  178.    end;
  179. end;
  180.  
  181.  
  182. BEGIN
  183.    Mark(HeapTop);
  184.    New ( Page[1] );
  185.    New ( Page[2] );
  186.    ClrScr;
  187.    Stall := 10;
  188.    CurrentAtt := 0;
  189.  
  190.    {---   Get file of menus that was created with ScrGen   ---}
  191.    Disk2Mem ( 'PullDown.Gen', 1, Page[1], Ecode );
  192.    if Ecode <> 0 then begin
  193.       Writeln('PullDown.Gen not found.  Program halted.');
  194.       Release ( HeapTop );
  195.       halt;
  196.    end;
  197.  
  198.    {---   Copy menu bar to screen   ---}
  199.    Heap2Scr ( Page[1], 1,1, 80,1, 1,1);
  200.  
  201.    {---   Get video attribute of menu bar   ---}
  202.    att := GetAtt (1,1);
  203.  
  204.    {---   Write Program identifying information and instructions   ---}
  205.    ShowMessages;
  206.  
  207.    {---   Save current screen image to heap page 2   ---}
  208.    SaveScreen ( Page[2] );
  209.  
  210.    repeat
  211.       {---   Wait for keypress   ---}
  212.       c := readkey;
  213.  
  214.       {---   Check for plus & minus keys   ---}
  215.       {---   Plus key increases menu scrolling speed   ---}
  216.       {---   Minus key decreases menu scrolling speed   ---}
  217.       if c in ['+','-'] then begin
  218.          case c of
  219.             '-' : if stall > 0 then
  220.                      stall := stall - 1;
  221.             '+' : stall := stall + 1;
  222.          end;
  223.          PutStr(h,fstr(stall,3),43,15,14);
  224.          Scr2Heap ( Page[2], 43,15,45,15,43,15);
  225.       end;
  226.  
  227.       {---   Check for 'A' key to change visual attributes of menus   ---}
  228.       if UpCase(c) = 'A' then begin
  229.          if CurrentAtt < 5 then
  230.             CurrentAtt := CurrentAtt + 1
  231.          else
  232.             CurrentAtt := 0;
  233.          HeapAtt ( Page[1],1,2,80,25, Attributes[CurrentAtt] );
  234.          PutStr(h,fstr(attributes[CurrentAtt],3),41,17,14);
  235.          Scr2Heap ( Page[2], 41,17,43,17,41,17);
  236.       end;
  237.  
  238.       {---   Show first menu user selects   ---}
  239.       if c = #0 then begin
  240.          c := readkey;
  241.          SelectMenu;
  242.          ShowNextMenu;
  243.  
  244.          {---   Display menus as left & right arrow keys pressed   ---}
  245.          {---   Stop menuing on ESCAPE; Halt program on ALT-Q   ---}
  246.          if c <> ALTQ then begin
  247.             repeat
  248.                Wait4Key;
  249.                if c in [RA,LA] then begin
  250.                   EraseCurMenu;
  251.                   ShowNextMenu;
  252.                end
  253.                else if c = ESC then
  254.                   EraseCurMenu;
  255.             until c in [ESC,ALTQ];
  256.          end;
  257.       end;
  258.    until c = ALTQ;
  259.  
  260.    Release ( HeapTop );
  261.  
  262. END.
  263.